home *** CD-ROM | disk | FTP | other *** search
/ NeXT Education Software Sampler 1992 Fall / NeXT Education Software Sampler 1992 Fall.iso / Programming / Source / winterp-1.13 / src-server / xlisp / xlisp.h < prev    next >
Encoding:
C/C++ Source or Header  |  1991-10-04  |  14.5 KB  |  439 lines
  1. /* -*-C-*-
  2. ********************************************************************************
  3. *
  4. * File:         xlisp.h
  5. * RCS:          $Header: xlisp.h,v 1.9 91/03/14 03:37:06 mayer Exp $
  6. * Description:  libXlisp.a external interfaces
  7. * Author:       David Michael Betz; Niels Mayer
  8. * Created:      
  9. * Modified:     Fri Oct  4 04:04:11 1991 (Niels Mayer) mayer@hplnpm
  10. * Language:     C
  11. * Package:      N/A
  12. * Status:       X11r5 contrib tape release
  13. *
  14. * WINTERP Copyright 1989, 1990, 1991 Hewlett-Packard Company (by Niels Mayer).
  15. * XLISP version 2.1, Copyright (c) 1989, by David Betz.
  16. *
  17. * Permission to use, copy, modify, distribute, and sell this software and its
  18. * documentation for any purpose is hereby granted without fee, provided that
  19. * the above copyright notice appear in all copies and that both that
  20. * copyright notice and this permission notice appear in supporting
  21. * documentation, and that the name of Hewlett-Packard and David Betz not be
  22. * used in advertising or publicity pertaining to distribution of the software
  23. * without specific, written prior permission.  Hewlett-Packard and David Betz
  24. * make no representations about the suitability of this software for any
  25. * purpose. It is provided "as is" without express or implied warranty.
  26. *
  27. * HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS
  28. * SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS,
  29. * IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL,
  30. * INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
  31. * LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
  32. * OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
  33. * PERFORMANCE OF THIS SOFTWARE.
  34. *
  35. * See ./winterp/COPYRIGHT for information on contacting the authors.
  36. * 
  37. * Please send modifications, improvements and bugfixes to mayer@hplabs.hp.com
  38. * Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x
  39. *
  40. ********************************************************************************
  41. */
  42.  
  43. /* system specific definitions */
  44. /* #define UNIX */
  45.  
  46. #include <stdio.h>
  47. #include <ctype.h>
  48. #include <setjmp.h>
  49.  
  50. /* NNODES    number of nodes to allocate in each request (1000) */
  51. /* EDEPTH    evaluation stack depth (2000) */
  52. /* ADEPTH    argument stack depth (1000) */
  53. /* FORWARD    type of a forward declaration () */
  54. /* LOCAL    type of a local function (static) */
  55. /* AFMT        printf format for addresses ("%x") */
  56. /* FIXTYPE    data type for fixed point numbers (long) */
  57. /* ITYPE    fixed point input conversion routine type (long atol()) */
  58. /* ICNV        fixed point input conversion routine (atol) */
  59. /* IFMT        printf format for fixed point numbers ("%ld") */
  60. /* FLOTYPE    data type for floating point numbers (float) */
  61. /* OFFTYPE    number the size of an address (int) */
  62.  
  63. #ifdef WINTERP            /* WINTERP assumes UNIX */
  64. #define XLISP_VERSION_INT 2 /* used in ../winterp.c */
  65. #define XLISP_REVISION_INT 10 /* used in ../winterp.c */
  66. #define NNODES        2000
  67. #define AFMT        "%lx"
  68. #define OFFTYPE        long
  69. /* #define SAVERESTORE */  /* NOTE: WINTERP breaks save/restore functionality
  70.                               because I haven't implemented a way to make
  71.                   Xtoolkit/Motif objects (WIDGETOBJs, PIXMAPs, PIXELs,
  72.                   CALLBACKOBJs, TIMEOUTOBJs, EVHANDLEROBJs) persist across
  73.                   invocations. Currently all the code in xlimage.c just
  74.                   assumes that all pointers are xlisp pointers and
  75.                   doesn't try to handle pointers to objects created
  76.                   outside of xlisp. Implementing save/restore for
  77.                   WINTERP is doable, but is not high on my priority
  78.                   list right now. Note that WINTERP doesn't break
  79.                   save/restore for standard xlisp objects. However, since
  80.                   it doesn't work correctly I've disabled it for now. */
  81. #endif
  82.  
  83. /* for BSD & SYSV Unix. */
  84. #ifdef UNIX
  85. #define NNODES        2000
  86. #define AFMT        "%lx"    /* added by NPM */
  87. #define OFFTYPE        long    /* added by NPM */
  88. #define SAVERESTORE
  89. #endif
  90.  
  91. /* for the Turbo C compiler - MS-DOS, large model */
  92. #ifdef _TURBOC_
  93. #define NNODES        2000
  94. #define AFMT        "%lx"
  95. #define OFFTYPE        long
  96. #define SAVERESTORE
  97. #endif
  98.  
  99. /* for the AZTEC C compiler - MS-DOS, large model */
  100. #ifdef AZTEC_LM
  101. #define NNODES        2000
  102. #define AFMT        "%lx"
  103. #define OFFTYPE        long
  104. #define CVPTR(x)    ptrtoabs(x)
  105. #define NIL        (void *)0
  106. extern long ptrtoabs();
  107. #define SAVERESTORE
  108. #endif
  109.  
  110. /* for the AZTEC C compiler - Macintosh */
  111. #ifdef AZTEC_MAC
  112. #define NNODES        2000
  113. #define AFMT        "%lx"
  114. #define OFFTYPE        long
  115. #define NIL        (void *)0
  116. #define SAVERESTORE
  117. #endif
  118.  
  119. /* for the AZTEC C compiler - Amiga */
  120. #ifdef AZTEC_AMIGA
  121. #define NNODES        2000
  122. #define AFMT        "%lx"
  123. #define OFFTYPE        long
  124. #define NIL        (void *)0
  125. #define SAVERESTORE
  126. #endif
  127.  
  128. /* for the Lightspeed C compiler - Macintosh */
  129. #ifdef LSC
  130. #define NNODES        2000
  131. #define AFMT        "%lx"
  132. #define OFFTYPE        long
  133. #define NIL        (void *)0
  134. #define SAVERESTORE
  135. #endif
  136.  
  137. /* for the Microsoft C compiler - MS-DOS, large model */
  138. #ifdef MSC
  139. #define NNODES        2000
  140. #define AFMT        "%lx"
  141. #define OFFTYPE        long
  142. #endif
  143.  
  144. /* for the Mark Williams C compiler - Atari ST */
  145. #ifdef MWC
  146. #define AFMT        "%lx"
  147. #define OFFTYPE        long
  148. #endif
  149.  
  150. /* for the Lattice C compiler - Atari ST */
  151. #ifdef LATTICE
  152. #define FIXTYPE        int
  153. #define ITYPE        int atoi()
  154. #define ICNV(n)        atoi(n)
  155. #define IFMT        "%d"
  156. #endif
  157.  
  158. /* for the Digital Research C compiler - Atari ST */
  159. #ifdef DR
  160. #define LOCAL
  161. #define AFMT        "%lx"
  162. #define OFFTYPE        long
  163. #undef NULL
  164. #define NULL        0L
  165. #endif
  166.  
  167. /* default important definitions */
  168. #ifndef NNODES
  169. #define NNODES        1000
  170. #endif
  171. #ifndef EDEPTH
  172. #define EDEPTH        2000
  173. #endif
  174. #ifndef ADEPTH
  175. #define ADEPTH        1000
  176. #endif
  177. #ifndef FORWARD
  178. #define FORWARD
  179. #endif
  180. #ifndef LOCAL
  181. #define LOCAL        static
  182. #endif
  183. #ifndef AFMT
  184. #define AFMT        "%x"
  185. #endif
  186. #ifndef FIXTYPE
  187. #define FIXTYPE        long
  188. #endif
  189. #ifndef ITYPE
  190. #define ITYPE        long atol()
  191. #endif
  192. #ifndef ICNV
  193. #define ICNV(n)        atol(n)
  194. #endif
  195. #ifndef IFMT
  196. #define IFMT        "%ld"
  197. #endif
  198. #ifndef FLOTYPE
  199. #define FLOTYPE        double
  200. #endif
  201. #ifndef OFFTYPE
  202. #define OFFTYPE        int
  203. #endif
  204. #ifndef CVPTR
  205. #define CVPTR(x)    (x)
  206. #endif
  207. #ifndef UCHAR
  208. #define UCHAR        unsigned char
  209. #endif
  210.  
  211. /* useful definitions */
  212. #define TRUE    1
  213. #define FALSE    0
  214. #ifndef NIL
  215. #define NIL    (LVAL )0
  216. #endif
  217.  
  218. /* include the dynamic memory definitions */
  219. #include "xldmem.h"
  220.  
  221. /* program limits */
  222. #define STRMAX        100        /* maximum length of a string constant */
  223. #ifdef WINTERP
  224. #define HSIZE        1019        /* symbol hash table size */
  225. #else
  226. #define HSIZE        199        /* symbol hash table size */
  227. #endif
  228. #define SAMPLE        100        /* control character sample rate */
  229.  
  230. /* function table offsets for the initialization functions */
  231. #define FT_RMHASH    0
  232. #define FT_RMQUOTE    1
  233. #define FT_RMDQUOTE    2
  234. #define FT_RMBQUOTE    3
  235. #define FT_RMCOMMA    4
  236. #define FT_RMLPAR    5
  237. #define FT_RMRPAR    6
  238. #define FT_RMSEMI    7
  239. #define FT_CLNEW    10
  240. #define FT_CLISNEW    11
  241. #define FT_CLANSWER    12
  242. #define FT_OBISNEW    13
  243. #define FT_OBCLASS    14
  244. #define FT_OBSHOW    15
  245.  
  246. /* macro to push a value onto the argument stack */
  247. #define pusharg(x)    {if (xlsp >= xlargstktop) xlargstkoverflow();\
  248.              *xlsp++ = (x);}
  249.  
  250. /* macros to protect pointers */
  251. #define xlstkcheck(n)    {if (xlstack - (n) < xlstkbase) xlstkoverflow();}
  252. #define xlsave(n)    {*--xlstack = &n; n = NIL;}
  253. #define xlprotect(n)    {*--xlstack = &n;}
  254.  
  255. /* check the stack and protect a single pointer */
  256. #define xlsave1(n)    {if (xlstack <= xlstkbase) xlstkoverflow();\
  257.                          *--xlstack = &n; n = NIL;}
  258. #define xlprot1(n)    {if (xlstack <= xlstkbase) xlstkoverflow();\
  259.                          *--xlstack = &n;}
  260.  
  261. /* macros to pop pointers off the stack */
  262. #define xlpop()        {++xlstack;}
  263. #define xlpopn(n)    {xlstack+=(n);}
  264.  
  265. /* macros to manipulate the lexical environment */
  266. #define xlframe(e)    cons(NIL,e)
  267. #define xlbind(s,v)    xlpbind(s,v,xlenv)
  268. #define xlfbind(s,v)    xlpbind(s,v,xlfenv);
  269. #define xlpbind(s,v,e)    {rplaca(e,cons(cons(s,v),car(e)));}
  270.  
  271. /* macros to manipulate the dynamic environment */
  272. #define xldbind(s,v)    {xldenv = cons(cons(s,getvalue(s)),xldenv);\
  273.              setvalue(s,v);}
  274. #define xlunbind(e)    {for (; xldenv != (e); xldenv = cdr(xldenv))\
  275.                setvalue(car(car(xldenv)),cdr(car(xldenv)));}
  276.  
  277. /* type predicates */                   
  278. #define atom(x)        ((x) == NIL || ntype(x) != CONS)
  279. #define null(x)        ((x) == NIL)
  280. #define listp(x)    ((x) == NIL || ntype(x) == CONS)
  281. #define consp(x)    ((x) && ntype(x) == CONS)
  282. #define subrp(x)    ((x) && ntype(x) == SUBR)
  283. #define fsubrp(x)    ((x) && ntype(x) == FSUBR)
  284. #define stringp(x)    ((x) && ntype(x) == STRING)
  285. #define symbolp(x)    ((x) && ntype(x) == SYMBOL)
  286.  
  287. #if (defined(UNIX) || defined(WINTERP))
  288. #define streamp(x)    ((x) && ((ntype(x) == STREAM) || (ntype(x) == XLTYPE_PIPE)))
  289. #else /* !(defined(UNIX) || defined(WINTERP)) */
  290. #define streamp(x)    ((x) && ntype(x) == STREAM)
  291. #endif /* (defined(UNIX) || defined(WINTERP)) */
  292.  
  293. #ifdef WINTERP
  294. #define objectp(x)    ((x) && ((ntype(x) == OBJECT) || (ntype(x) == XLTYPE_WIDGETOBJ)))
  295. #else
  296. #define objectp(x)    ((x) && ntype(x) == OBJECT)
  297. #endif
  298.  
  299. #define fixp(x)        ((x) && ntype(x) == FIXNUM)
  300. #define floatp(x)    ((x) && ntype(x) == FLONUM)
  301. #define vectorp(x)    ((x) && ntype(x) == VECTOR)
  302. #define closurep(x)    ((x) && ntype(x) == CLOSURE)
  303. #define charp(x)    ((x) && ntype(x) == CHAR)
  304. #define ustreamp(x)    ((x) && ntype(x) == USTREAM)
  305. #define structp(x)    ((x) && ntype(x) == STRUCT)
  306. #define boundp(x)    (getvalue(x) != s_unbound)
  307. #define fboundp(x)    (getfunction(x) != s_unbound)
  308.  
  309. #if (defined(UNIX) || defined(WINTERP))
  310. #define pipe_p(x)     ((x) && (ntype(x) == XLTYPE_PIPE))
  311. #endif /* (defined(UNIX) || defined(WINTERP)) */
  312.  
  313. #ifdef WINTERP
  314. #define xtresource_p(x)  ((x) && (ntype(x) == XLTYPE_XT_RESOURCE))
  315. #define pixel_p(x)       ((x) && (ntype(x) == XLTYPE_Pixel))
  316. #define pixmap_p(x)      ((x) && (ntype(x) == XLTYPE_Pixmap))
  317. #define ximage_p(x)      ((x) && (ntype(x) == XLTYPE_XImage))
  318. #define callbackobj_p(x) ((x) && (ntype(x) == XLTYPE_CALLBACKOBJ))
  319. #define timeoutobj_p(x)  ((x) && (ntype(x) == XLTYPE_TIMEOUTOBJ))
  320. #define widgetobj_p(x)   ((x) && (ntype(x) == XLTYPE_WIDGETOBJ))
  321. #define xmstring_p(x)     ((x) && (ntype(x) == XLTYPE_XmString))
  322. #define xevent_p(x)      ((x) && (ntype(x) == XLTYPE_XEvent))
  323. #define xtaccelerators_p(x) ((x) && (ntype(x) == XLTYPE_XtAccelerators))
  324. #define xttranslations_p(x) ((x) && (ntype(x) == XLTYPE_XtTranslations))
  325. #define evhandlerobj_p(x)   ((x) && (ntype(x) == XLTYPE_EVHANDLEROBJ))
  326. #endif                /* WINTERP */
  327.  
  328. /* shorthand functions */
  329. #define consa(x)    cons(x,NIL)
  330. #define consd(x)    cons(NIL,x)
  331.  
  332. /* argument list parsing macros */
  333. #define xlgetarg()    (testarg(nextarg()))
  334. #define xllastarg()    {if (xlargc != 0) xltoomany();}
  335. #define testarg(e)    (moreargs() ? (e) : xltoofew())
  336. #define typearg(tp)    (tp(*xlargv) ? nextarg() : xlbadtype(*xlargv))
  337. #define nextarg()    (--xlargc, *xlargv++)
  338. #define moreargs()    (xlargc > 0)
  339.  
  340. /* macros to get arguments of a particular type */
  341. #define xlgacons()    (testarg(typearg(consp)))
  342. #define xlgalist()    (testarg(typearg(listp)))
  343. #define xlgasymbol()    (testarg(typearg(symbolp)))
  344. #define xlgastring()    (testarg(typearg(stringp)))
  345. #define xlgaobject()    (testarg(typearg(objectp)))
  346. #define xlgafixnum()    (testarg(typearg(fixp)))
  347. #define xlgaflonum()    (testarg(typearg(floatp)))
  348. #define xlgachar()    (testarg(typearg(charp)))
  349. #define xlgavector()    (testarg(typearg(vectorp)))
  350. #define xlgastream()    (testarg(typearg(streamp)))
  351. #define xlgaustream()    (testarg(typearg(ustreamp)))
  352. #define xlgaclosure()    (testarg(typearg(closurep)))
  353. #define xlgastruct()    (testarg(typearg(structp)))
  354.  
  355. #if (defined(UNIX) || defined(WINTERP))
  356. #define xlga_pipe()    (testarg(typearg(pipe_p)))
  357. #endif /* (defined(UNIX) || defined(WINTERP)) */
  358.  
  359. #ifdef WINTERP
  360. #define xlga_timeoutobj()    (testarg(typearg(timeoutobj_p)))
  361. #define xlga_callbackobj()    (testarg(typearg(callbackobj_p)))
  362. #define xlga_ximage()        (testarg(typearg(ximage_p)))
  363. #define xlga_widgetobj()    (testarg(typearg(widgetobj_p)))
  364. #define xlga_xevent()        (testarg(typearg(xevent_p)))
  365. #define xlga_xttranslations()    (testarg(typearg(xttranslations_p)))
  366. #define xlga_xtaccelerators()    (testarg(typearg(xtaccelerators_p)))
  367. #define xlga_evhandlerobj()    (testarg(typearg(evhandlerobj_p)))
  368. #define xlga_xmstring()        (testarg(typearg(xmstring_p)))
  369. #define xlga_pixel()        (testarg(typearg(pixel_p)))
  370. #endif
  371.  
  372. /* function definition structure */
  373. typedef struct {
  374.     char *fd_name;    /* function name */
  375.     int fd_type;    /* function type */
  376.     LVAL (*fd_subr)();    /* function entry point */
  377. } FUNDEF;
  378.  
  379. /* execution context flags */
  380. #define CF_GO        0x0001
  381. #define CF_RETURN    0x0002
  382. #define CF_THROW    0x0004
  383. #define CF_ERROR    0x0008
  384. #define CF_CLEANUP    0x0010
  385. #define CF_CONTINUE    0x0020
  386. #define CF_TOPLEVEL    0x0040
  387. #define CF_BRKLEVEL    0x0080
  388. #define CF_UNWIND    0x0100
  389.  
  390. /* execution context */
  391. typedef struct context {
  392.     int c_flags;            /* context type flags */
  393.     LVAL c_expr;            /* expression (type dependant) */
  394.     jmp_buf c_jmpbuf;            /* longjmp context */
  395.     struct context *c_xlcontext;    /* old value of xlcontext */
  396.     LVAL **c_xlstack;            /* old value of xlstack */
  397.     LVAL *c_xlargv;            /* old value of xlargv */
  398.     int c_xlargc;            /* old value of xlargc */
  399.     LVAL *c_xlfp;            /* old value of xlfp */
  400.     LVAL *c_xlsp;            /* old value of xlsp */
  401.     LVAL c_xlenv;            /* old value of xlenv */
  402.     LVAL c_xlfenv;            /* old value of xlfenv */
  403.     LVAL c_xldenv;            /* old value of xldenv */
  404. } CONTEXT;
  405.  
  406. /* external variables */
  407. extern LVAL **xlstktop;           /* top of the evaluation stack */
  408. extern LVAL **xlstkbase;    /* base of the evaluation stack */
  409. extern LVAL **xlstack;        /* evaluation stack pointer */
  410. extern LVAL *xlargstkbase;    /* base of the argument stack */
  411. extern LVAL *xlargstktop;    /* top of the argument stack */
  412. extern LVAL *xlfp;        /* argument frame pointer */
  413. extern LVAL *xlsp;        /* argument stack pointer */
  414. extern LVAL *xlargv;        /* current argument vector */
  415. extern int xlargc;        /* current argument count */
  416.  
  417. /* external procedure declarations */
  418. extern LVAL xleval();        /* evaluate an expression */
  419. extern LVAL xlapply();        /* apply a function to arguments */
  420. extern LVAL xlsubr();        /* enter a subr/fsubr */
  421. extern LVAL xlenter();        /* enter a symbol */
  422. extern LVAL xlmakesym();    /* make an uninterned symbol */
  423. extern LVAL xlgetvalue();    /* get value of a symbol (checked) */
  424. extern LVAL xlxgetvalue();    /* get value of a symbol */
  425. extern LVAL xlgetfunction();    /* get functional value of a symbol */
  426. extern LVAL xlxgetfunction();    /* get functional value of a symbol (checked) */
  427. extern LVAL xlexpandmacros();    /* expand macros in a form */
  428. extern LVAL xlgetprop();    /* get the value of a property */
  429. extern LVAL xlclose();        /* create a function closure */
  430.  
  431. /* argument list parsing functions */
  432. extern LVAL xlgetfile();          /* get a file/stream argument */
  433. extern LVAL xlgetfname();    /* get a filename argument */
  434.  
  435. /* error reporting functions (don't *really* return at all) */
  436. extern LVAL xltoofew();        /* report "too few arguments" error */
  437. extern LVAL xlbadtype();    /* report "bad argument type" error */
  438.  
  439.